home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Mode Examples / Lisp-Example.el < prev    next >
Encoding:
Text File  |  2000-10-30  |  55.5 KB  |  1,434 lines
  1. ;; 
  2.  ; ==========================================================================
  3.  ; Lisp-Example.el
  4.  ; 
  5.  ; Distributed as an example of Alpha's Lisp mode.
  6.  ;  
  7.  ; Lisp mode is available at
  8.  ; 
  9.  ; <http://www.princeton.edu/~cupright/computing/alpha/>
  10.  ; ==========================================================================
  11.  ;;
  12.  
  13. ;;; S-mode.el --- Support for editing S source code
  14. ;; Copyright (C) 1989-2000 Bates, Kademan, Ritter and Smith
  15.  
  16. ;; Author: David Smith <dsmith@stats.adelaide.edu.au>
  17. ;; Maintainer: David Smith <dsmith@stats.adelaide.edu.au>
  18. ;; Created: 7 Jan 1994
  19. ;; Modified: $Date: 1997/03/10 16:16:21 $
  20. ;; Version: $Revision: 1.21 $
  21. ;; RCS: $Id: S-mode.el,v 1.21 1997/03/10 16:16:21 rossini Exp $
  22.  
  23. ;;
  24. ;; $Log: S-mode.el,v $
  25. ;; Revision 1.21  1997/03/10 16:16:21  rossini
  26. ;; added hooks for XEmacs menu
  27. ;;
  28. ;; Revision 1.20  1997/03/07 23:34:51  rossini
  29. ;; moved relevant S-menu stuff into S-mode.
  30. ;;
  31. ;; Revision 1.19  1997/03/07 20:59:25  rossini
  32. ;; added Kurt H.'s version of S-mark-function.
  33. ;; changed settings for R-mode (ala Kurt H.)
  34. ;;
  35. ;; Revision 1.18  1997/02/10 17:36:14  rossini
  36. ;; removed the additional work, again.
  37. ;; It's not happening, this time.
  38. ;;
  39. ;; Revision 1.17  1997/02/10 16:55:52  rossini
  40. ;; fixed my stupid patching, I hope!
  41. ;;
  42. ;; Revision 1.16  1997/02/09 21:34:05  rossini
  43. ;; menus correct for S-mode (keymaps not inherited from comint, but
  44. ;; rather from text-mode!  Whoops!)
  45. ;;
  46. ;;
  47.  
  48. ;; This file is part of S-mode
  49.  
  50. ;; This file is free software; you can redistribute it and/or modify
  51. ;; it under the terms of the GNU General Public License as published by
  52. ;; the Free Software Foundation; either version 2, or (at your option)
  53. ;; any later version.
  54.  
  55. ;; This file is distributed in the hope that it will be useful,
  56. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  57. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  58. ;; GNU General Public License for more details.
  59.  
  60. ;; You should have received a copy of the GNU General Public License
  61. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  62. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  63.  
  64. ;;; Commentary:
  65.  
  66. ;; Code for editing S source code. See S.el for more details.
  67.  
  68. ;;; Code:
  69.  
  70. ;;; Requires and autoloads
  71.  
  72. (require 'S)
  73.  
  74. (autoload 'S-mode-minibuffer-map "S-inf" "" nil 'keymap)
  75. (autoload 'S-read-object-name "S-inf" "" nil)
  76. (autoload 'S-list-object-completions "S-inf" "" nil)
  77.  
  78. ;;; User changeable variables
  79. ;;;=====================================================
  80. ;;; Users note: Variables with document strings starting
  81. ;;; with a * are the ones you can generally change safely, and
  82. ;;; may have to upon occasion.
  83.  
  84. (defvar S-mode-silently-save t
  85.   "*If non-nil, automatically save S source buffers before loading")
  86.  
  87. ;;*;; Variables controlling editing
  88.  
  89. ;;;*;;; Edit buffer processing
  90. (defvar S-function-template " <- function( )\n{\n\n}\n"
  91.   "If non-nil, function template used when editing nonexistent objects.
  92. The edit buffer will contain the object name in quotes, followed by
  93. this string. Point will be placed after the first parenthesis or
  94. bracket.")
  95.  
  96. ;;; By K.Shibayama 5.14.1992
  97. ;;; Setting any of the following variables in your .emacs is equivalent
  98. ;;; to modifying the DEFAULT style.
  99.  
  100. ;;;*;;; Indentation parameters
  101.  
  102. (defvar S-auto-newline nil
  103.   "*Non-nil means automatically newline before and after braces
  104. inserted in S code.")
  105.  
  106. (defvar S-tab-always-indent t
  107.   "*Non-nil means TAB in S mode should always reindent the current line,
  108. regardless of where in the line point is when the TAB command is used.")
  109.  
  110. (defvar S-indent-level 2
  111.   "*Indentation of S statements with respect to containing block.")
  112.  
  113. (defvar S-brace-imaginary-offset 0
  114.   "*Imagined indentation of a S open brace that actually follows a statement.")
  115.  
  116. (defvar S-brace-offset 0
  117.   "*Extra indentation for braces, compared with other text in same context.")
  118.  
  119. (defvar S-continued-statement-offset 2
  120.   "*Extra indent for lines not starting new statements.")
  121.  
  122. (defvar S-continued-brace-offset 0
  123.   "*Extra indent for substatements that start with open-braces.
  124. This is in addition to S-continued-statement-offset.")
  125.  
  126. (defvar S-arg-function-offset 2
  127.   "*Extra indent for internal substatements of function `foo' that called
  128. in `arg=foo(...)' form.
  129. If not number, the statements are indented at open-parenthesis following foo.")
  130.  
  131. (defvar S-else-offset 2
  132.   "*Extra indent for `else' lines.")
  133.  
  134. (defvar S-expression-offset 4
  135.   "*Extra indent for internal substatements of `expression' that specified
  136. in `obj <- expression(...)' form.
  137. If not number, the statements are indented at open-parenthesis following
  138. `expression'.")
  139.  
  140. ;;;*;;; Editing styles
  141.  
  142. (defvar S-default-style-list
  143.   (list 'DEFAULT
  144.         (cons 'S-indent-level S-indent-level)
  145.         (cons 'S-continued-statement-offset S-continued-statement-offset)
  146.         (cons 'S-brace-offset S-brace-offset)
  147.         (cons 'S-expression-offset S-expression-offset)
  148.         (cons 'S-else-offset S-else-offset)
  149.         (cons 'S-brace-imaginary-offset S-brace-imaginary-offset)
  150.         (cons 'S-continued-brace-offset S-continued-brace-offset)
  151.         (cons 'S-arg-function-offset S-arg-function-offset))
  152.   "Default style constructed from initial values of indentation variables.")
  153.  
  154. (defvar S-style-alist
  155.   (cons S-default-style-list
  156.         '((GNU (S-indent-level . 2)
  157.                (S-continued-statement-offset . 2)
  158.                (S-brace-offset . 0)
  159.                (S-arg-function-offset . 4)
  160.                (S-expression-offset . 2)
  161.                (S-else-offset . 0))
  162.           (BSD (S-indent-level . 8)
  163.                (S-continued-statement-offset . 8)
  164.                (S-brace-offset . -8)
  165.                (S-arg-function-offset . 0)
  166.                (S-expression-offset . 8)
  167.                (S-else-offset . 0))
  168.           (K&R (S-indent-level . 5)
  169.                (S-continued-statement-offset . 5)
  170.                (S-brace-offset . -5)
  171.                (S-arg-function-offset . 0)
  172.                (S-expression-offset . 5)
  173.                (S-else-offset . 0))
  174.           (C++ (S-indent-level . 4)
  175.                (S-continued-statement-offset . 4)
  176.                (S-brace-offset . -4)
  177.                (S-arg-function-offset . 0)
  178.                (S-expression-offset . 4)
  179.                (S-else-offset . 0))))
  180.   "Predefined formatting styles for S code")
  181.  
  182. (defvar S-default-style 'DEFAULT
  183.   "*The default value of S-style")
  184.  
  185. (defvar S-style S-default-style
  186.   "*The buffer specific S indentation style.")
  187.  
  188. ;;*;; Variables controlling behaviour of dump files
  189.  
  190. (defvar S-source-directory "/tmp/"
  191.   "*Directory in which to place dump files.
  192. This can be a string (an absolute directory name ending in a slash) or
  193. a lambda expression of no arguments which will return a suitable string
  194. value.  The lambda expression is evaluated with the process buffer as the
  195. current buffer.")
  196. ;;; Possible value:
  197. ;;; '(lambda () (file-name-as-directory
  198. ;;;           (expand-file-name (concat (car S-search-list) "/.Src"))))
  199. ;;; This always dumps to a sub-directory (".Src") of the current S
  200. ;;; working directory (i.e. first elt of search list)
  201.  
  202. (defvar S-dump-filename-template (concat (user-login-name) ".%s.S")
  203.   "*Template for filenames of dumped objects.
  204. %s is replaced by the object name.")
  205. ;;; This gives filenames like `user.foofun.S', so as not to clash with
  206. ;;; other users if you are using a shared directory. Other alternatives:
  207. ;;; "%s.S" ; Don't bother uniquifying if using your own directory(ies)
  208. ;;; "dump" ; Always dump to a specific filename. This makes it impossible
  209. ;;;          to edit more than one object at a time, though.
  210. ;;; (make-temp-name "scr.") ; Another way to uniquify
  211.  
  212. ;;; System variables
  213. ;;;=====================================================
  214. ;;; Users note: You will rarely have to change these
  215. ;;; variables.
  216.  
  217. ;;*;; Regular expressions
  218.  
  219. (defvar S-function-pattern
  220.   (concat
  221.    "\\(" ; EITHER
  222.    "\\s\"" ; quote
  223.    "\\(\\sw\\|\\s_\\)+" ; symbol
  224.    "\\s\"" ; quote
  225.    "\\s-*\\(<-\\|_\\)\\(\\s-\\|\n\\)*" ; whitespace, assign, whitespace/nl
  226.    "function\\s-*(" ; function keyword, parenthesis
  227.    "\\)\\|\\(" ; OR
  228.    "\\<\\(\\sw\\|\\s_\\)+" ; symbol
  229.    "\\s-*\\(<-\\|_\\)\\(\\s-\\|\n\\)*" ; whitespace, assign, whitespace/nl
  230.    "function\\s-*(" ; function keyword, parenthesis
  231.    "\\)")
  232.   "The regular expression for matching the beginning of an S function.")
  233.  
  234. (defvar S-dumped-missing-re
  235.   "\\(<-\nDumped\n\\'\\)\\|\\(<-\\(\\s \\|\n\\)*\\'\\)"
  236.   "If a dumped object's buffer matches this re, then it is replaced
  237. by S-function-template.")
  238.  
  239. (defvar S-dump-error-re
  240.   (if (string= S-version-running "3.0") "\nDumped\n\\'" "[Ee]rror")
  241.   "Regexp used to detect an error when loading a file.")
  242.  
  243. ;;*;; Miscellaneous system variables
  244.  
  245. (defvar S-source-modes '(S-mode)
  246.   "A list of modes used to determine if a buffer contains S source code.")
  247. ;;; If a file is loaded into a buffer that is in one of these major modes, it
  248. ;;; is considered an S source file.  The function S-load-file uses this to
  249. ;;; determine defaults.
  250.  
  251. (defvar S-error-buffer-name "*S-errors*"
  252.   "Name of buffer to keep error messages in.")
  253.  
  254. ;;*;; Font-lock support
  255. (defvar S-mode-font-lock-keywords
  256.  '(("\\s\"?\\(\\(\\sw\\|\\s_\\)+\\)\\s\"?\\s-*\\(<-\\|_\\)\\(\\s-\\|\n\\)*function" 1 font-lock-function-name-face t)
  257.    ("<-" . font-lock-reference-face)
  258.    ("\\<\\(TRUE\\|FALSE\\|T\\|F\\|NA\\|NULL\\|Inf\\|NaN\\)\\>" . font-lock-type-face)
  259.    ("\\<\\(library\\|attach\\|detach\\|source\\)\\>" . font-lock-reference-face)
  260.    "\\<\\(while\\|for\\|in\\|repeat\\|if\\|else\\|switch\\|break\\|next\\|return\\|stop\\|warning\\|function\\)\\>")
  261.  "Font-lock patterns used in S-mode bufffers.")
  262.  
  263.  
  264. ;;; S mode
  265. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  266. ;;;; In this section:
  267. ;;;;
  268. ;;;; * The major mode S-mode
  269. ;;;; * Commands for S-mode
  270. ;;;; * Code evaluation commands
  271. ;;;; * Indenting code and commands
  272. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  273.  
  274. ;;*;; Major mode definition
  275. (defvar S-mode-map nil)
  276. (if S-mode-map
  277.     nil
  278.  
  279.   (cond ((string-match "XEmacs\\|Lucid" emacs-version)
  280.          ;; Code for XEmacs
  281.          (setq S-mode-map (make-keymap))
  282.          (set-keymap-parent S-mode-map text-mode-map) ;; was comint?!?
  283.          ))
  284.  
  285.   (cond ((not (string-match "XEmacs\\|Lucid" emacs-version))
  286.          ;; Code specific to FSF GNU Emacs
  287.          (setq S-mode-map (make-sparse-keymap))))
  288.  
  289.   (define-key S-mode-map "\C-c\C-r"    'S-eval-region)
  290.   (define-key S-mode-map "\C-c\M-r"    'S-eval-region-and-go)
  291.   (define-key S-mode-map "\C-c\C-b"    'S-eval-buffer)
  292.   (define-key S-mode-map "\C-c\M-b"    'S-eval-buffer-and-go)
  293.   (define-key S-mode-map "\C-c\C-f"    'S-eval-function)
  294.   (define-key S-mode-map "\C-c\M-f"    'S-eval-function-and-go)
  295.   (define-key S-mode-map "\M-\C-x"     'S-eval-function)
  296.   (define-key S-mode-map "\C-c\C-n"    'S-eval-line-and-next-line)
  297.   (define-key S-mode-map "\C-c\C-j"    'S-eval-line)
  298.   (define-key S-mode-map "\C-c\M-j"    'S-eval-line-and-go)
  299.   (define-key S-mode-map "\M-\C-a"     'S-beginning-of-function)
  300.   (define-key S-mode-map "\M-\C-e"     'S-end-of-function)
  301.   (define-key S-mode-map "\C-c\C-y"    'S-switch-to-S)
  302.   (define-key S-mode-map "\C-c\C-z"    'S-switch-to-end-of-S)
  303.   (define-key S-mode-map "\C-c\C-l"    'S-load-file)
  304.   (define-key S-mode-map "\C-c\C-v"    'S-display-help-on-object)
  305.   (define-key S-mode-map "\C-c\C-d"    'S-dump-object-into-edit-buffer)
  306. ;(define-key S-mode-map "\C-c5\C-d"'S-dump-object-into-edit-buffer-other-frame)
  307.   (define-key S-mode-map "\C-c\C-t"    'S-execute-in-tb)
  308.   (define-key S-mode-map "\C-c\t"      'S-complete-object-name)
  309.   (define-key S-mode-map "\M-\t"       'comint-replace-by-expanded-filename)
  310.   (define-key S-mode-map "\M-?"        'S-list-object-completions)
  311.   ;; wrong here (define-key S-mode-map "\C-c\C-k" 'S-request-a-process)
  312.   (define-key S-mode-map "\C-c\C-k"    'S-force-buffer-current)
  313.   (define-key S-mode-map "\C-x`"       'S-parse-errors)
  314.   (define-key S-mode-map "{"           'S-electric-brace)
  315.   (define-key S-mode-map "}"           'S-electric-brace)
  316.   (define-key S-mode-map "\e\C-h"      'S-mark-function)
  317.   (define-key S-mode-map "\e\C-q"      'S-indent-exp)
  318.   (define-key S-mode-map "\177"        'backward-delete-char-untabify)
  319.   (define-key S-mode-map "\t"          'S-indent-command)
  320. )
  321.  
  322.  
  323.  
  324.  
  325.  
  326.  
  327.  
  328. (easy-menu-define
  329.  S-mode-menu S-mode-map
  330.  "Menu for use in S-mode"
  331.  '("S-mode"
  332.    ["Describe"  describe-mode t]
  333.    ;;["About"  (lambda nil (interactive) (S-goto-info "Editing")) t]
  334.    ["Send bug report"  S-submit-bug-report t]    
  335.    "------"
  336.    ["Load file"  S-load-file t]
  337.    ("Eval and Go"
  338.     ["Eval buffer"   S-eval-buffer-and-go   t]
  339.     ["Eval region"   S-eval-region-and-go   t]
  340.     ["Eval function" S-eval-function-and-go t]
  341.     ["Eval line"     S-eval-line-and-go     t]
  342.     ;;["About" (lambda nil (interactive) (S-goto-info "Evaluating code")) t]
  343.     )
  344.    ("S Eval"
  345.     ["Eval buffer"       S-eval-buffer             t]
  346.     ["Eval region"       S-eval-region             t]
  347.     ["Eval function"     S-eval-function           t]
  348.     ["Step through line" S-eval-line-and-next-line t]
  349.     ["Enter expression"  S-execute-in-tb           t]
  350.     ["Eval line"         S-eval-line               t]
  351.     ;;["About" (lambda nil (interactive) (S-goto-info "Evaluating code"))]
  352.     )
  353.    ("Motion..." 
  354.     ["Edit new object"       S-dump-object-into-edit-buffer t]
  355.     ["Goto end of S buffer"  S-switch-to-end-of-S           t]
  356.     ["Switch to S buffer"    S-switch-to-S                  t]
  357.     ["End of function"      S-end-of-function              t]
  358.     ["Beginning of function" S-beginning-of-function        t])
  359.    ("S list..."
  360.     ["Backward list"         backward-list                   t]
  361.     ["Forward list"          forward-list                    t]
  362.     ["Next parenthesis"      down-list                       t]
  363.     ["Enclosing parenthesis" backward-up-list                t]
  364.     ["Backward sexp"         backward-sexp                   t]
  365.     ["Forward sexp"          forward-sexp                    t]
  366.     ;;["About"                 (Info-goto-node "(Emacs)Lists") t]
  367.     )
  368.    ("S Edit"
  369.     ["Complete Filename" comint-replace-by-expanded-filename t]
  370.     ["Complete Object"   S-complete-object-name              t]
  371.     ["Kill sexp"         kill-sexp                           t]
  372.     ["Mark function"     S-mark-function                     t]
  373.     ["Indent expression" S-indent-exp                        t]
  374.     ["Indent line"       S-indent-command                    t]
  375.     ["Undo"              undo                                t]
  376.     ;;["About"   (lambda nil (interactive) (S-goto-info "Edit buffer")) t]
  377.     )
  378.    ))
  379.  
  380. (if (not (string-match "XEmacs" emacs-version))
  381.     (progn
  382.       (if (featurep 'S-mode)
  383.            (define-key S-mode-map
  384.              [menu-bar S-mode]
  385.              (cons "S-mode" S-mode-menu))
  386.          (eval-after-load "S-mode"
  387.                           '(define-key S-mode-map
  388.                              [menu-bar S-mode]
  389.                              (cons "S-mode"
  390.                                    S-mode-menu))))))
  391.  
  392. (defun S-mode-xemacs-menu ()
  393.   "Hook to install S-mode menu for XEmacs (w/ easymenu)"
  394.   (if 'S-mode
  395.         (easy-menu-add S-mode-menu)
  396.     (easy-menu-remove S-mode-menu)))
  397.  
  398. (if (string-match "XEmacs" emacs-version)
  399.     (add-hook 'S-mode-hook 'S-mode-xemacs-menu))
  400.  
  401.  
  402. (defun R-mode  (&optional proc-name) 
  403.   "Major mode for editing R source.  See S-mode for more help."
  404.   (interactive)
  405.   (setq S-proc-prefix "R"
  406.         ;; S-set-style "GNU"
  407.         S-default-style 'GNU
  408.         )
  409.   (S-mode proc-name))
  410.  
  411. (defun S-mode (&optional proc-name)
  412.   "Major mode for editing S source.
  413. Optional arg PROC-NAME is name of associated inferior process.
  414.  
  415. \\{S-mode-map}
  416.  
  417. Customization: Entry to this mode runs the hooks in S-mode-hook.
  418.  
  419. You can send text to the inferior S process from other buffers containing
  420. S source.
  421.     S-eval-region sends the current region to the S process.
  422.     S-eval-buffer sends the current buffer to the S process.
  423.     S-eval-function sends the current function to the S process.
  424.     S-eval-line sends the current line to the S process.
  425.     S-beginning-of-function and S-end-of-function move the point to
  426.         the beginning and end of the current S function.
  427.     S-switch-to-S switches the current buffer to the S process buffer.
  428.     S-switch-to-end-of-S switches the current buffer to the S process
  429.         buffer and puts point at the end of it.
  430.  
  431.     S-eval-region-and-go, S-eval-buffer-and-go,
  432.         S-eval-function-and-go, and S-eval-line-and-go switch to the S
  433.         process buffer after sending their text.
  434.  
  435.     S-load-file sources a file of commands to the S process.
  436.  
  437. \\[S-indent-command] indents for S code.
  438. \\[backward-delete-char-untabify] converts tabs to spaces as it moves back.
  439. Comments are indented in a similar way to Emacs-lisp mode:
  440.        `###'     beginning of line
  441.        `##'      the same level of indentation as the code
  442.        `#'       the same column on the right, or to the right of such a
  443.                  column if that is not possible.(default value 40).
  444.                  \\[indent-for-comment] command automatically inserts such a
  445.                  `#' in the right place, or aligns such a comment if it is
  446.                  already inserted.
  447. \\[S-indent-exp] command indents each line of the S grouping following point.
  448.  
  449. Variables controlling indentation style:
  450.  S-tab-always-indent
  451.     Non-nil means TAB in S mode should always reindent the current line,
  452.     regardless of where in the line point is when the TAB command is used.
  453.  S-auto-newline
  454.     Non-nil means automatically newline before and after braces inserted in S
  455.     code.
  456.  S-indent-level
  457.     Indentation of S statements within surrounding block.
  458.     The surrounding block's indentation is the indentation of the line on
  459.     which the open-brace appears.
  460.  S-continued-statement-offset
  461.     Extra indentation given to a substatement, such as the then-clause of an
  462.     if or body of a while.
  463.  S-continued-brace-offset
  464.     Extra indentation given to a brace that starts a substatement.
  465.     This is in addition to S-continued-statement-offset.
  466.  S-brace-offset
  467.     Extra indentation for line if it starts with an open brace.
  468.  S-arg-function-offset
  469.     Extra indent for internal substatements of function `foo' that called
  470.     in `arg=foo(...)' form.
  471.    If not number, the statements are indented at open-parenthesis following
  472.    `foo'.
  473.  S-expression-offset
  474.     Extra indent for internal substatements of `expression' that specified
  475.     in `obj <- expression(...)' form.
  476.     If not number, the statements are indented at open-parenthesis following
  477.     `expression'.
  478.  S-brace-imaginary-offset
  479.     An open brace following other text is treated as if it were
  480.     this far to the right of the start of its line.
  481.  S-else-offset
  482.     Extra indentation for line if it starts with `else'.
  483.  
  484. Furthermore, \\[S-set-style] command enables you to set up predefined S-mode
  485. indentation style. At present, predefined style are `BSD', `GNU', `K&R' `C++'
  486.  (quoted from C language style)."
  487.   (interactive)
  488.   (kill-all-local-variables)
  489.   (setq major-mode 'S-mode)
  490.   (setq mode-name "S")
  491.   (use-local-map S-mode-map)
  492.   (set-syntax-table S-mode-syntax-table)
  493.   (make-local-variable 'paragraph-start)
  494.   (setq paragraph-start (concat "^$\\|" page-delimiter))
  495.   (make-local-variable 'paragraph-separate)
  496.   (setq paragraph-separate paragraph-start)
  497.   (make-local-variable 'paragraph-ignore-fill-prefix)
  498.   (setq paragraph-ignore-fill-prefix t)
  499.   (make-local-variable 'indent-line-function)
  500.   (setq indent-line-function 'S-indent-line)
  501.   (make-local-variable 'require-final-newline)
  502.   (setq require-final-newline t)
  503.   (make-local-variable 'comment-start)
  504.   (setq comment-start "#")
  505.   (make-local-variable 'comment-start-skip)
  506.   (setq comment-start-skip "#+ *")
  507.   (make-local-variable 'comment-column)
  508.   (setq comment-column 40)
  509.   (make-local-variable 'comment-indent-function)
  510.   (setq comment-indent-function 'S-comment-indent)
  511.   (make-local-variable 'parse-sexp-ignore-comments)
  512.   (setq parse-sexp-ignore-comments t)
  513.   (S-set-style S-default-style)
  514.   (make-local-variable 'S-local-process-name)
  515.   (make-local-variable 'S-keep-dump-files)
  516.   (put 'S-local-process-name 'permanent-local t) ; protect from RCS
  517.   (setq mode-line-process ;; AJR: in future, XEmacs will use modeline-process.
  518.         '(" [" (S-local-process-name S-local-process-name "none") "]"))
  519.   ;; font-lock support
  520.   (make-local-variable 'font-lock-defaults)
  521.   (setq font-lock-defaults '(S-mode-font-lock-keywords))
  522.   (run-hooks 'S-mode-hook))
  523.  
  524. ;;*;; User commands in S-mode
  525.  
  526. ;;;*;;; Handy commands
  527.  
  528. (defun S-execute-in-tb nil
  529.   "Like S-execute, but always evaluates in temp buffer."
  530.   (interactive)
  531.   (let ((S-execute-in-process-buffer nil))
  532.     (call-interactively 'S-execute)))
  533.  
  534. ;;;*;;; Buffer motion/manipulation commands
  535.  
  536. (defun S-beginning-of-function nil
  537.   "Leave the point at the beginning of the current S function."
  538.   (interactive)
  539.   (let ((init-point (point))
  540.         beg end done)
  541.     (if (search-forward "(" nil t) (forward-char 1))
  542.     ;; in case we're sitting in a function header
  543.     (while (not done)
  544.       (if
  545.           (re-search-backward S-function-pattern (point-min) t)
  546.           nil
  547.         (goto-char init-point)
  548.         (error "Point is not in a function."))
  549.       (setq beg (point))
  550.       (forward-list 1)                  ; get over arguments
  551.       (forward-sexp 1)                  ; move over braces
  552.       (setq end (point))
  553.       (goto-char beg)
  554.       ;; current function must begin and end around point
  555.       (setq done (and (>= end init-point) (<= beg init-point))))))
  556.  
  557.  
  558. (defun S-end-of-function nil
  559.   "Leave the point at the end of the current S function."
  560.   (interactive)
  561.   (S-beginning-of-function)
  562.   (forward-list 1)                      ; get over arguments
  563.   (forward-sexp 1)                      ; move over braces
  564.   )
  565.  
  566. (defun S-extract-word-name ()
  567.   "Get the word you're on."
  568.   (save-excursion
  569.     (re-search-forward "\\<\\w+\\>" nil t)
  570.     (buffer-substring (match-beginning 0) (match-end 0))))
  571.  
  572. ;;; Original S-mode 4.8.6 version
  573. ;;(defun S-mark-function ()
  574. ;;  "Put mark at end of S function, point at beginning."
  575. ;;  (interactive)
  576. ;;  (push-mark (point))
  577. ;;  (S-end-of-function)
  578. ;;  (push-mark (point))
  579. ;;  (S-beginning-of-function))
  580.  
  581. ;;; Kurt's version, suggested 970306.
  582. (defun S-mark-function ()
  583.   "Put mark at end of S function, point at beginning."
  584.   (interactive)
  585.   (S-beginning-of-function)
  586.   (push-mark (point))
  587.   (S-end-of-function)
  588.   (exchange-point-and-mark))
  589.  
  590. ;;*;; Code evaluation commands
  591.  
  592. ;;;*;;; Evaluate only
  593.  
  594. (defun S-eval-region (start end toggle &optional message)
  595.   "Send the current region to the inferior S process.
  596. With prefix argument, toggle meaning of S-eval-visibly-p."
  597.   (interactive "r\nP")
  598.   (require 'S-inf)                      ; for S-eval-visibly-p
  599.   (S-force-buffer-current "Process to load into: ")
  600.   (let ((visibly (if toggle (not S-eval-visibly-p) S-eval-visibly-p)))
  601.     (if visibly
  602.         (S-eval-visibly (buffer-substring start end))
  603.       (if S-synchronize-evals
  604.           (S-eval-visibly (buffer-substring start end)
  605.                           (or message "Eval region"))
  606.         (process-send-region (get-S-process S-current-process-name)
  607.                              start end)
  608.         (process-send-string (get-S-process S-current-process-name)
  609.                              "\n")))))
  610.  
  611. (defun S-eval-buffer (vis)
  612.   "Send the current buffer to the inferior S process.
  613. Arg has same meaning as for S-eval-region."
  614.   (interactive "P")
  615.   (S-eval-region (point-min) (point-max) vis "Eval buffer"))
  616.  
  617. (defun S-eval-function (vis)
  618.   "Send the current function to the inferior S process.
  619. Arg has same meaning as for S-eval-region."
  620.   (interactive "P")
  621.   (save-excursion
  622.     (S-end-of-function)
  623.     (let ((end (point)))
  624.       (S-beginning-of-function)
  625.       (princ (concat "Loading: " (S-extract-word-name)) t)
  626.       (S-eval-region (point) end vis
  627.                      (concat "Eval function " (S-extract-word-name))))))
  628.  
  629. (defun S-eval-line (vis)
  630.   "Send the current line to the inferior S process.
  631. Arg has same meaning as for S-eval-region."
  632.   (interactive "P")
  633.   (save-excursion
  634.     (end-of-line)
  635.     (let ((end (point)))
  636.       (beginning-of-line)
  637.       (princ (concat "Loading line: " (S-extract-word-name) " ...") t)
  638.       (S-eval-region (point) end vis "Eval line"))))
  639. (defun S-eval-line-and-next-line ()
  640.   "Evaluate the current line visibly and move to the next line."
  641.   ;; From an idea by Rod Ball (rod@marcam.dsir.govt.nz)
  642.   (interactive)
  643.   (save-excursion
  644.     (end-of-line)
  645.     (let ((end (point)))
  646.       (beginning-of-line)
  647.       ;; RDB modified to go to end of S buffer so user can see result
  648.       (S-eval-visibly (buffer-substring (point) end) nil t)))
  649.   (next-line 1))
  650.  
  651. ;; goes to the real front, in case you do double function definition
  652. ;; 29-Jul-92 -FER
  653. ;; don't know why David changed it.
  654.  
  655. ;; FER's versions don't work properly with nested functions. Replaced
  656. ;; mine. DMS 16 Nov 92
  657.  
  658. ;;;*;;; Evaluate and switch to S
  659.  
  660. (defun S-eval-region-and-go (start end vis)
  661.   "Send the current region to the inferior S and switch to the process buffer.
  662. Arg has same meaning as for S-eval-region."
  663.   (interactive "r\nP")
  664.   (S-eval-region start end vis)
  665.   (S-switch-to-S t))
  666.  
  667. (defun S-eval-buffer-and-go (vis)
  668.   "Send the current buffer to the inferior S and switch to the process buffer.
  669. Arg has same meaning as for S-eval-region."
  670.   (interactive "P")
  671.   (S-eval-buffer vis)
  672.   (S-switch-to-S t))
  673.  
  674. (defun S-eval-function-and-go (vis)
  675.   "Send the current function to the inferior S process and switch to
  676. the process buffer. Arg has same meaning as for S-eval-region."
  677.   (interactive "P")
  678.   (S-eval-function vis)
  679.   (S-switch-to-S t))
  680.  
  681. (defun S-eval-line-and-go (vis)
  682.   "Send the current line to the inferior S process and switch to the
  683. process buffer. Arg has same meaning as for S-eval-region."
  684.   (interactive "P")
  685.   (S-eval-line vis)
  686.   (S-switch-to-S t))
  687.  
  688. ;;*;; Loading files
  689.  
  690. (defun S-force-buffer-current (prompt &optional force)
  691.   "Make sure the current buffer is attached to an S process. If not,
  692. prompt for a process name with PROMPT. S-local-process-name is set to
  693. the name of the process selected."
  694.   (interactive 
  695.    (list (concat S-proc-prefix " process to use: ") prefix-arg))
  696.   (if (S-make-buffer-current) nil
  697.     ;; Make sure the source buffer is attached to a process
  698.     (if S-local-process-name
  699.         (error "Process %s has died." S-local-process-name)
  700.       ;; S-local-process-name is nil -- which process to attach to
  701.       (save-excursion
  702.         (let ((proc (S-request-a-process prompt 'no-switch)))
  703.           (make-local-variable 'S-local-process-name)
  704.           (setq S-local-process-name proc)
  705.           ;; why is the mode line not updated ??
  706.           )))))
  707.  
  708. (defun S-check-modifications nil
  709.   "Check whether loading this file would overwrite some S objects
  710. which have been modified more recently than this file, and confirm
  711. if this is the case."
  712.   ;; FIXME: this should really cycle through all top-level assignments in
  713.   ;; the buffer
  714.   (and (buffer-file-name) S-inf-filenames-map
  715.        (let ((sourcemod (nth 5 (file-attributes (buffer-file-name))))
  716.              (objname))
  717.          (save-excursion
  718.            (goto-char (point-min))
  719.            ;; Get name of assigned object, if we can find it
  720.            (setq objname
  721.                  (and
  722.                   (re-search-forward "^\\s *\"?\\(\\(\\sw\\|\\s_\\)+\\)\"?\\s *[<_]" nil t)
  723.                   (buffer-substring (match-beginning 1) (match-end 1)))))
  724.          (and
  725.           sourcemod                     ; the file may have been deleted
  726.           objname                       ; may not have been able to find name
  727.           (S-modtime-gt (S-object-modtime objname) sourcemod)
  728.           (not (y-or-n-p (format "The S object %s is newer than this file. Continue? " objname)))
  729.           (error "Aborted")))))
  730.  
  731. (defun S-check-source (fname)
  732.   "If file FNAME has an unsaved buffer, offer to save it.
  733. Returns t if the buffer existed and was modified, but was not saved"
  734.   (let ((buff (get-file-buffer fname)))
  735.     (if buff
  736.         (let ((deleted (not (file-exists-p (buffer-file-name)))))
  737.           (if (and deleted (not (buffer-modified-p buff)))
  738.               ;; Buffer has been silently deleted, so silently save
  739.               (save-excursion
  740.                 (set-buffer buff)
  741.                 (set-buffer-modified-p t)
  742.                 (save-buffer))
  743.             (if (and (buffer-modified-p buff)
  744.                      (or S-mode-silently-save
  745.                          (y-or-n-p
  746.                           (format "Save buffer %s first? "
  747.                                   (buffer-name buff)))))
  748.                 (save-excursion
  749.                   (set-buffer buff)
  750.                   (save-buffer))))
  751.           (buffer-modified-p buff)))))
  752.  
  753. (defun S-load-file (filename)
  754.   "Load an S source file into an inferior S process."
  755.   (interactive (list
  756.                 (or
  757.                  (and (eq major-mode 'S-mode) (buffer-file-name))
  758.                  (expand-file-name
  759.                   (read-file-name "Load S file: " nil nil t)))))
  760.   (require 'S-inf)
  761.   (S-make-buffer-current)
  762.   (let ((source-buffer (get-file-buffer filename)))
  763.     (if (S-check-source filename)
  764.         (error "Buffer %s has not been saved" (buffer-name source-buffer))
  765.       ;; Find the process to load into
  766.       (if source-buffer
  767.           (save-excursion
  768.             (set-buffer source-buffer)
  769.     (S-force-buffer-current "Process to load into: ")
  770.             (S-check-modifications))))
  771.     (let ((errbuffer (S-create-temp-buffer S-error-buffer-name))
  772.           error-occurred nomessage)
  773.       (S-command (format inferior-S-load-command filename) errbuffer)
  774.       (save-excursion
  775.         (set-buffer errbuffer)
  776.         (goto-char (point-max))
  777.         (setq error-occurred (re-search-backward S-dump-error-re nil t))
  778.         (setq nomessage (= (buffer-size) 0)))
  779.       (if error-occurred
  780.           (message "Errors: Use %s to find error."
  781.                    (substitute-command-keys
  782.                     "\\<inferior-S-mode-map>\\[S-parse-errors]"))
  783.         ;; Load did not cause an error
  784.         (if nomessage (message "Load successful.")
  785.           ;; There was a warning message from S
  786.           (S-display-temp-buffer errbuffer))
  787.         ;; Consider deleting the file
  788.         (let ((skdf (if source-buffer
  789.                         (save-excursion
  790.                           (set-buffer source-buffer)
  791.                           S-keep-dump-files)
  792.                       S-keep-dump-files))) ;; global value
  793.           (cond
  794.            ((null skdf)
  795.             (delete-file filename))
  796.            ((memq skdf '(check ask))
  797.             (let ((doit (y-or-n-p (format "Delete %s " filename))))
  798.               (if doit (delete-file filename))
  799.               (and source-buffer
  800.                    (local-variable-p 'S-keep-dump-files source-buffer)
  801.                    (save-excursion
  802.                      (set-buffer source-buffer)
  803.                      (setq S-keep-dump-files doit)))))))
  804.         (S-switch-to-S t)))))
  805.  
  806. (defun S-parse-errors (showerr)
  807.   "Jump to error in last loaded S source file.
  808. With prefix argument, only shows the errors S reported."
  809.   (interactive "P")
  810.   (S-make-buffer-current)
  811.   (let ((errbuff (get-buffer S-error-buffer-name)))
  812.     (if (not errbuff)
  813.         (error "You need to do a load first!")
  814.       (set-buffer errbuff)
  815.       (goto-char (point-max))
  816.       (if
  817.           (re-search-backward
  818.            "^\\(Syntax error: .*\\) at line \\([0-9]*\\), file \\(.*\\)$"
  819.            nil
  820.            t)
  821.           (let* ((filename (buffer-substring (match-beginning 3) (match-end 3)))
  822.                  (fbuffer (get-file-buffer filename))
  823.                  (linenum (string-to-int (buffer-substring (match-beginning 2) (match-end 2))))
  824.                  (errmess (buffer-substring (match-beginning 1) (match-end 1))))
  825.             (if showerr
  826.                   (S-display-temp-buffer errbuff)
  827.               (if fbuffer nil
  828.                 (setq fbuffer (find-file-noselect filename))
  829.                 (save-excursion
  830.                   (set-buffer fbuffer)
  831.                   (S-mode)))
  832.               (pop-to-buffer fbuffer)
  833.               (goto-line linenum))
  834.             (princ errmess t))
  835.         (message "Not a syntax error.")
  836.         (S-display-temp-buffer errbuff)))))
  837.  
  838. ;;*;; S code formatting/indentation
  839.  
  840. ;;;*;;; User commands
  841.  
  842. (defun S-electric-brace (arg)
  843.   "Insert character and correct line's indentation."
  844.   (interactive "P")
  845.   (let (insertpos)
  846.     (if (and (not arg)
  847.              (eolp)
  848.              (or (save-excursion
  849.                    (skip-chars-backward " \t")
  850.                    (bolp))
  851.                  (if S-auto-newline (progn (S-indent-line) (newline) t) nil)))
  852.         (progn
  853.           (insert last-command-char)
  854.           (S-indent-line)
  855.           (if S-auto-newline
  856.               (progn
  857.                 (newline)
  858.                 ;; (newline) may have done auto-fill
  859.                 (setq insertpos (- (point) 2))
  860.                 (S-indent-line)))
  861.           (save-excursion
  862.             (if insertpos (goto-char (1+ insertpos)))
  863.             (delete-char -1))))
  864.     (if insertpos
  865.         (save-excursion
  866.           (goto-char insertpos)
  867.           (self-insert-command (prefix-numeric-value arg)))
  868.       (self-insert-command (prefix-numeric-value arg)))))
  869.  
  870. (defun S-indent-command (&optional whole-exp)
  871.   "Indent current line as S code, or in some cases insert a tab character.
  872. If S-tab-always-indent is non-nil (the default), always indent current line.
  873. Otherwise, indent the current line only if point is at the left margin
  874. or in the line's indentation; otherwise insert a tab.
  875.  
  876. A numeric argument, regardless of its value,
  877. means indent rigidly all the lines of the expression starting after point
  878. so that this line becomes properly indented.
  879. The relative indentation among the lines of the expression are preserved."
  880.   (interactive "P")
  881.   (if whole-exp
  882.       ;; If arg, always indent this line as S
  883.       ;; and shift remaining lines of expression the same amount.
  884.       (let ((shift-amt (S-indent-line))
  885.             beg end)
  886.         (save-excursion
  887.           (if S-tab-always-indent
  888.               (beginning-of-line))
  889.           (setq beg (point))
  890.           (backward-up-list 1)
  891.           (forward-list 1)
  892.           (setq end (point))
  893.           (goto-char beg)
  894.           (forward-line 1)
  895.           (setq beg (point)))
  896.         (if (> end beg)
  897.             (indent-code-rigidly beg end shift-amt)))
  898.     (if (and (not S-tab-always-indent)
  899.              (save-excursion
  900.                (skip-chars-backward " \t")
  901.                (not (bolp))))
  902.         (insert-tab)
  903.       (S-indent-line))))
  904.  
  905. (defun S-indent-exp ()
  906.   "Indent each line of the S grouping following point."
  907.   (interactive)
  908.   (let ((indent-stack (list nil))
  909.         (contain-stack (list (point)))
  910.         (case-fold-search nil)
  911.         restart outer-loop-done innerloop-done state ostate
  912.         this-indent last-sexp last-depth
  913.         at-else at-brace
  914.         (opoint (point))
  915.         (next-depth 0))
  916.     (save-excursion
  917.       (forward-sexp 1))
  918.     (save-excursion
  919.       (setq outer-loop-done nil)
  920.       (while (and (not (eobp)) (not outer-loop-done))
  921.         (setq last-depth next-depth)
  922.         ;; Compute how depth changes over this line
  923.         ;; plus enough other lines to get to one that
  924.         ;; does not end inside a comment or string.
  925.         ;; Meanwhile, do appropriate indentation on comment lines.
  926.         (setq innerloop-done nil)
  927.         (while (and (not innerloop-done)
  928.                     (not (and (eobp) (setq outer-loop-done t))))
  929.           (setq ostate state)
  930.           (setq state (parse-partial-sexp (point) (progn (end-of-line) (point))
  931.                                           nil nil state))
  932.           (setq next-depth (car state))
  933.           (if (and (car (cdr (cdr state)))
  934.                    (>= (car (cdr (cdr state))) 0))
  935.               (setq last-sexp (car (cdr (cdr state)))))
  936.           (if (or (nth 4 ostate))
  937.               (S-indent-line))
  938.           (if (nth 4 state)
  939.               (and (S-indent-line)
  940.                    (setcar (nthcdr 4 state) nil)))
  941.           (if (or (nth 3 state))
  942.               (forward-line 1)
  943.             (setq innerloop-done t)))
  944.         (if (<= next-depth 0)
  945.             (setq outer-loop-done t))
  946.         (if outer-loop-done
  947.             nil
  948.           ;; If this line had ..))) (((.. in it, pop out of the levels
  949.           ;; that ended anywhere in this line, even if the final depth
  950.           ;; doesn't indicate that they ended.
  951.           (while (> last-depth (nth 6 state))
  952.             (setq indent-stack (cdr indent-stack)
  953.                   contain-stack (cdr contain-stack)
  954.                   last-depth (1- last-depth)))
  955.           (if (/= last-depth next-depth)
  956.               (setq last-sexp nil))
  957.           ;; Add levels for any parens that were started in this line.
  958.           (while (< last-depth next-depth)
  959.             (setq indent-stack (cons nil indent-stack)
  960.                   contain-stack (cons nil contain-stack)
  961.                   last-depth (1+ last-depth)))
  962.           (if (null (car contain-stack))
  963.               (setcar contain-stack (or (car (cdr state))
  964.                                         (save-excursion (forward-sexp -1)
  965.                                                         (point)))))
  966.           (forward-line 1)
  967.           (skip-chars-forward " \t")
  968.           (if (eolp)
  969.               nil
  970.             (if (and (car indent-stack)
  971.                      (>= (car indent-stack) 0))
  972.                 ;; Line is on an existing nesting level.
  973.                 ;; Lines inside parens are handled specially.
  974.                 (if (/= (char-after (car contain-stack)) ?{)
  975.                     (setq this-indent (car indent-stack))
  976.                   ;; Line is at statement level.
  977.                   ;; Is it a new statement?  Is it an else?
  978.                   ;; Find last non-comment character before this line
  979.                   (save-excursion
  980.                     (setq at-else (looking-at "else\\W"))
  981.                     (setq at-brace (= (following-char) ?{))
  982.                     (S-backward-to-noncomment opoint)
  983.                     (if (S-continued-statement-p)
  984.                         ;; Preceding line did not end in comma or semi;
  985.                         ;; indent this line  S-continued-statement-offset
  986.                         ;; more than previous.
  987.                         (progn
  988.                           (S-backward-to-start-of-continued-exp (car contain-stack))
  989.                           (setq this-indent
  990.                                 (+ S-continued-statement-offset (current-column)
  991.                                    (if at-brace S-continued-brace-offset 0))))
  992.                       ;; Preceding line ended in comma or semi;
  993.                       ;; use the standard indent for this level.
  994.                       (if at-else
  995.                           (progn (S-backward-to-start-of-if opoint)
  996.                                  (setq this-indent (+ S-else-offset
  997.                                                       (current-indentation))))
  998.                         (setq this-indent (car indent-stack))))))
  999.               ;; Just started a new nesting level.
  1000.               ;; Compute the standard indent for this level.
  1001.               (let ((val (S-calculate-indent
  1002.                            (if (car indent-stack)
  1003.                                (- (car indent-stack))))))
  1004.                 (setcar indent-stack
  1005.                         (setq this-indent val))))
  1006.             ;; Adjust line indentation according to its contents
  1007.             (if (= (following-char) ?})
  1008.                 (setq this-indent (- this-indent S-indent-level)))
  1009.             (if (= (following-char) ?{)
  1010.                 (setq this-indent (+ this-indent S-brace-offset)))
  1011.             ;; Put chosen indentation into effect.
  1012.             (or (= (current-column) this-indent)
  1013.                 (= (following-char) ?\#)
  1014.                 (progn
  1015.                   (delete-region (point) (progn (beginning-of-line) (point)))
  1016.                   (indent-to this-indent)))
  1017.             ;; Indent any comment following the text.
  1018.             (or (looking-at comment-start-skip)
  1019.                 (if (re-search-forward comment-start-skip (save-excursion (end-of-line) (point)) t)
  1020.                     (progn (indent-for-comment) (beginning-of-line)))))))))
  1021.                                         ; (message "Indenting S expression...done")
  1022.   )
  1023. ;;;*;;; Support functions for indentation
  1024.  
  1025. (defun S-comment-indent ()
  1026.   (if (looking-at "###")
  1027.       (current-column)
  1028.     (if (looking-at "##")
  1029.         (let ((tem (S-calculate-indent)))
  1030.           (if (listp tem) (car tem) tem))
  1031.       (skip-chars-backward " \t")
  1032.       (max (if (bolp) 0 (1+ (current-column)))
  1033.            comment-column))))
  1034.  
  1035. (defun S-indent-line ()
  1036.   "Indent current line as S code.
  1037. Return the amount the indentation changed by."
  1038.   (let ((indent (S-calculate-indent nil))
  1039.         beg shift-amt
  1040.         (case-fold-search nil)
  1041.         (pos (- (point-max) (point))))
  1042.     (beginning-of-line)
  1043.     (setq beg (point))
  1044.     (cond ((eq indent nil)
  1045.            (setq indent (current-indentation)))
  1046.           (t
  1047.            (skip-chars-forward " \t")
  1048.            (if (looking-at "###")
  1049.                (setq indent 0))
  1050.            (if (and (looking-at "#") (not (looking-at "##")))
  1051.                (setq indent comment-column)
  1052.              (if (eq indent t) (setq indent 0))
  1053.              (if (listp indent) (setq indent (car indent)))
  1054.              (cond ((and (looking-at "else\\b")
  1055.                          (not (looking-at "else\\s_")))
  1056.                     (setq indent (save-excursion
  1057.                                    (S-backward-to-start-of-if)
  1058.                                    (+ S-else-offset (current-indentation)))))
  1059.                    ((= (following-char) ?})
  1060.                     (setq indent (- indent S-indent-level)))
  1061.                    ((= (following-char) ?{)
  1062.                     (setq indent (+ indent S-brace-offset)))))))
  1063.     (skip-chars-forward " \t")
  1064.     (setq shift-amt (- indent (current-column)))
  1065.     (if (zerop shift-amt)
  1066.         (if (> (- (point-max) pos) (point))
  1067.             (goto-char (- (point-max) pos)))
  1068.       (delete-region beg (point))
  1069.       (indent-to indent)
  1070.       ;; If initial point was within line's indentation,
  1071.       ;; position after the indentation.
  1072.       ;; Else stay at same point in text.
  1073.       (if (> (- (point-max) pos) (point))
  1074.           (goto-char (- (point-max) pos))))
  1075.     shift-amt))
  1076.  
  1077. (defun S-calculate-indent (&optional parse-start)
  1078.   "Return appropriate indentation for current line as S code.
  1079. In usual case returns an integer: the column to indent to.
  1080. Returns nil if line starts inside a string, t if in a comment."
  1081.   (save-excursion
  1082.     (beginning-of-line)
  1083.     (let ((indent-point (point))
  1084.           (case-fold-search nil)
  1085.           state
  1086.           containing-sexp)
  1087.       (if parse-start
  1088.           (goto-char parse-start)
  1089.         (beginning-of-defun))
  1090.       (while (< (point) indent-point)
  1091.         (setq parse-start (point))
  1092.         (setq state (parse-partial-sexp (point) indent-point 0))
  1093.         (setq containing-sexp (car (cdr state))))
  1094.       (cond ((or (nth 3 state) (nth 4 state))
  1095.              ;; return nil or t if should not change this line
  1096.              (nth 4 state))
  1097.             ((null containing-sexp)
  1098.              ;; Line is at top level.  May be data or function definition,
  1099.              (beginning-of-line)
  1100.              (if (and (/= (following-char) ?\{)
  1101.                       (save-excursion
  1102.                         (S-backward-to-noncomment (point-min))
  1103.                         (S-continued-statement-p)))
  1104.                  S-continued-statement-offset
  1105.                0))   ; Unless it starts a function body
  1106.             ((/= (char-after containing-sexp) ?{)
  1107.              ;; line is expression, not statement:
  1108.              ;; indent to just after the surrounding open.
  1109.              (goto-char containing-sexp)
  1110.              (let ((bol (save-excursion (beginning-of-line) (point))))
  1111.  
  1112.                ;; modified by shiba@isac 7.3.1992
  1113.                (cond ((and (numberp S-expression-offset)
  1114.                            (re-search-backward "[ \t]*expression[ \t]*" bol t))
  1115.                       ;; This regexp match every "expression".
  1116.                       ;; modified by shiba
  1117.                       ;;(forward-sexp -1)
  1118.                       (beginning-of-line)
  1119.                       (skip-chars-forward " \t")
  1120.                       ;; End
  1121.                       (+ (current-column) S-expression-offset))
  1122.                      ((and (numberp S-arg-function-offset)
  1123.                            (re-search-backward "=[ \t]*\\s\"*\\(\\w\\|\\s_\\)+\\s\"*[ \t]*" bol t))
  1124.                       (forward-sexp -1)
  1125.                       (+ (current-column) S-arg-function-offset))
  1126.                      ;; "expression" is searched before "=".
  1127.                      ;; End
  1128.  
  1129.                      (t
  1130.                       (progn (goto-char (1+ containing-sexp))
  1131.                              (current-column))))))
  1132.             (t
  1133.              ;; Statement level.  Is it a continuation or a new statement?
  1134.              ;; Find previous non-comment character.
  1135.              (goto-char indent-point)
  1136.              (S-backward-to-noncomment containing-sexp)
  1137.              ;; Back up over label lines, since they don't
  1138.              ;; affect whether our line is a continuation.
  1139.              (while (eq (preceding-char) ?\,)
  1140.                (S-backward-to-start-of-continued-exp containing-sexp)
  1141.                (beginning-of-line)
  1142.                (S-backward-to-noncomment containing-sexp))
  1143.              ;; Now we get the answer.
  1144.              (if (S-continued-statement-p)
  1145.                  ;; This line is continuation of preceding line's statement;
  1146.                  ;; indent  S-continued-statement-offset  more than the
  1147.                  ;; previous line of the statement.
  1148.                  (progn
  1149.                    (S-backward-to-start-of-continued-exp containing-sexp)
  1150.                    (+ S-continued-statement-offset (current-column)
  1151.                       (if (save-excursion (goto-char indent-point)
  1152.                                           (skip-chars-forward " \t")
  1153.                                           (eq (following-char) ?{))
  1154.                           S-continued-brace-offset 0)))
  1155.                ;; This line starts a new statement.
  1156.                ;; Position following last unclosed open.
  1157.                (goto-char containing-sexp)
  1158.                ;; Is line first statement after an open-brace?
  1159.                (or
  1160.                  ;; If no, find that first statement and indent like it.
  1161.                  (save-excursion
  1162.                    (forward-char 1)
  1163.                    (while (progn (skip-chars-forward " \t\n")
  1164.                                  (looking-at "#"))
  1165.                      ;; Skip over comments following openbrace.
  1166.                      (forward-line 1))
  1167.                    ;; The first following code counts
  1168.                    ;; if it is before the line we want to indent.
  1169.                    (and (< (point) indent-point)
  1170.                         (current-column)))
  1171.                  ;; If no previous statement,
  1172.                  ;; indent it relative to line brace is on.
  1173.                  ;; For open brace in column zero, don't let statement
  1174.                  ;; start there too.  If S-indent-level is zero,
  1175.                  ;; use S-brace-offset + S-continued-statement-offset instead.
  1176.                  ;; For open-braces not the first thing in a line,
  1177.                  ;; add in S-brace-imaginary-offset.
  1178.                  (+ (if (and (bolp) (zerop S-indent-level))
  1179.                         (+ S-brace-offset S-continued-statement-offset)
  1180.                       S-indent-level)
  1181.                     ;; Move back over whitespace before the openbrace.
  1182.                     ;; If openbrace is not first nonwhite thing on the line,
  1183.                     ;; add the S-brace-imaginary-offset.
  1184.                     (progn (skip-chars-backward " \t")
  1185.                            (if (bolp) 0 S-brace-imaginary-offset))
  1186.                     ;; If the openbrace is preceded by a parenthesized exp,
  1187.                     ;; move to the beginning of that;
  1188.                     ;; possibly a different line
  1189.                     (progn
  1190.                       (if (eq (preceding-char) ?\))
  1191.                           (forward-sexp -1))
  1192.                       ;; Get initial indentation of the line we are on.
  1193.                       (current-indentation))))))))))
  1194.  
  1195. (defun S-continued-statement-p ()
  1196.   (let ((eol (point)))
  1197.     (save-excursion
  1198.       (cond ((memq (preceding-char) '(nil ?\, ?\; ?\} ?\{ ?\]))
  1199.              nil)
  1200.             ;; ((bolp))
  1201.             ((= (preceding-char) ?\))
  1202.              (forward-sexp -2)
  1203.              (looking-at "if\\b[ \t]*(\\|function\\b[ \t]*(\\|for\\b[ \t]*(\\|while\\b[ \t]*("))
  1204.             ((progn (forward-sexp -1)
  1205.                     (and (looking-at "else\\b\\|repeat\\b")
  1206.                          (not (looking-at "else\\s_\\|repeat\\s_"))))
  1207.              (skip-chars-backward " \t")
  1208.              (or (bolp)
  1209.                  (= (preceding-char) ?\;)))
  1210.             (t
  1211.              (progn (goto-char eol)
  1212.                     (skip-chars-backward " \t")
  1213.                     (or (and (> (current-column) 1)
  1214.                              (save-excursion (backward-char 1)
  1215.                                              (looking-at "[-:+*/_><=]")))
  1216.                         (and (> (current-column) 3)
  1217.                              (progn (backward-char 3)
  1218.                                     (looking-at "%[^ \t]%"))))))))))
  1219. (defun S-backward-to-noncomment (lim)
  1220.   (let (opoint stop)
  1221.     (while (not stop)
  1222.       (skip-chars-backward " \t\n\f" lim)
  1223.       (setq opoint (point))
  1224.       (beginning-of-line)
  1225.       (search-forward "#" opoint 'move)
  1226.       (skip-chars-backward " \t#")
  1227.       (setq stop (or (/= (preceding-char) ?\n) (<= (point) lim)))
  1228.         (if stop (point)
  1229.           (beginning-of-line)))))
  1230.  
  1231. (defun S-backward-to-start-of-continued-exp (lim)
  1232.   (if (= (preceding-char) ?\))
  1233.       (forward-sexp -1))
  1234.   (beginning-of-line)
  1235.   (if (<= (point) lim)
  1236.       (goto-char (1+ lim)))
  1237.   (skip-chars-forward " \t"))
  1238.  
  1239. (defun S-backward-to-start-of-if (&optional limit)
  1240.   "Move to the start of the last ``unbalanced'' if."
  1241.   (or limit (setq limit (save-excursion (beginning-of-defun) (point))))
  1242.   (let ((if-level 1)
  1243.         (case-fold-search nil))
  1244.     (while (not (zerop if-level))
  1245.       (backward-sexp 1)
  1246.       (cond ((looking-at "else\\b")
  1247.              (setq if-level (1+ if-level)))
  1248.             ((looking-at "if\\b")
  1249.              (setq if-level (1- if-level)))
  1250.             ((< (point) limit)
  1251.              (setq if-level 0)
  1252.              (goto-char limit))))))
  1253.  
  1254. ;;;*;;; Predefined indentation styles
  1255.  
  1256. (defun S-set-style (&optional style)
  1257.   "Set up the S-mode style variables from the S-style variable or if
  1258.   STYLE argument is given, use that.  It makes the S indentation style
  1259.   variables buffer local."
  1260.  
  1261.   (interactive)
  1262.  
  1263.   (let ((S-styles (mapcar 'car S-style-alist)))
  1264.  
  1265.     (if (interactive-p)
  1266.         (setq style
  1267.               (let ((style-string ; get style name with completion
  1268.                      (completing-read
  1269.                       (format "Set S mode indentation style to (default %s): "
  1270.                               S-default-style)
  1271.                       (vconcat S-styles)
  1272.                       (function (lambda (arg) (memq arg S-styles)))
  1273.                       )))
  1274.                 (if (string-equal "" style-string)
  1275.                     S-default-style
  1276.                   (intern style-string))
  1277.                 )))
  1278.  
  1279.     (setq style (or style S-style)) ; use S-style if style is nil
  1280.  
  1281.     (make-local-variable 'S-style)
  1282.     (if (memq style S-styles)
  1283.         (setq S-style style)
  1284.       (error (concat "Bad S style: " style))
  1285.       )
  1286.     (message "S-style: %s" S-style)
  1287.  
  1288.     ; finally, set the indentation style variables making each one local
  1289.     (mapcar (function (lambda (S-style-pair)
  1290.                         (make-local-variable (car S-style-pair))
  1291.                         (set (car S-style-pair)
  1292.                              (cdr S-style-pair))))
  1293.             (cdr (assq S-style S-style-alist)))
  1294.     S-style))
  1295.  
  1296. ;;*;; Creating and manipulating dump buffers
  1297.  
  1298. ;;;*;;; The user command
  1299.  
  1300. (defun S-dump-object-into-edit-buffer (object)
  1301.   "Edit an S object in its own buffer.
  1302.  
  1303. Without a prefix argument, this simply finds the file pointed to by
  1304. S-source-directory. If this file does not exist, or if a
  1305. prefix argument is given, a dump() command is sent to the S process to
  1306. generate the source buffer."
  1307.   (interactive
  1308.    (progn
  1309.      (require 'S-inf)
  1310.      (S-force-buffer-current "Process to dump from: ")
  1311.      (S-read-object-name "Object to edit: ")))
  1312.   (let* ((dirname (file-name-as-directory
  1313.                    (if (stringp S-source-directory)
  1314.                        S-source-directory
  1315.                      (save-excursion
  1316.                        (set-buffer (process-buffer
  1317.                                     (get-S-process S-local-process-name)))
  1318.                        (apply S-source-directory nil)))))
  1319.          (filename (concat dirname (format S-dump-filename-template object)))
  1320.          (old-buff (get-file-buffer filename)))
  1321.  
  1322.     ;; If the directory doesn't exist, offer to create it
  1323.     (if (file-exists-p (directory-file-name dirname)) nil
  1324.       (if (y-or-n-p     ; Approved
  1325.            (format "Directory %s does not exist. Create it? " dirname))
  1326.           (make-directory (directory-file-name dirname))
  1327.         (error "Directory %s does not exist." dirname)))
  1328.  
  1329.     ;; Three options:
  1330.     ;;  (1) Pop to an existing buffer containing the file in question
  1331.     ;;  (2) Find an existing file
  1332.     ;;  (3) Create a new file by issuing a dump() command to S
  1333.     ;; Force option (3) if there is a prefix arg
  1334.  
  1335.     (if current-prefix-arg
  1336.         (S-dump-object object filename)
  1337.       (if old-buff
  1338.           (progn
  1339.             (pop-to-buffer old-buff)
  1340.             (message "Popped to edit buffer."))
  1341.         ;; No current buffer containing desired file
  1342.         (if (file-exists-p filename)
  1343.             (progn
  1344.               (S-find-dump-file-other-window filename)
  1345.               (message "Read %s" filename))
  1346.           ;; No buffer and no file
  1347.           (S-dump-object object filename))))))
  1348.  
  1349. (defun S-dump-object (object filename)
  1350.   "Dump the S object OBJECT into file FILENAME."
  1351.   (let ((complete-dump-command (format inferior-S-dump-command
  1352.                                        object filename)))
  1353.     (if (file-writable-p filename) nil
  1354.       (error "Can't dump %s as %f is not writeable." object filename))
  1355.  
  1356.     ;; Make sure we start fresh
  1357.     (if (get-file-buffer filename)
  1358.         (or (kill-buffer (get-file-buffer filename))
  1359.             (error "Aborted.")))
  1360.  
  1361.     (S-command complete-dump-command)
  1362.     (message "Dumped in %s" filename)
  1363.  
  1364.     (S-find-dump-file-other-window filename)
  1365.  
  1366.     ;; Don't make backups for temporary files; it only causes clutter.
  1367.     ;; The S object itself is a kind of backup, anyway.
  1368.     (if S-keep-dump-files nil
  1369.       (make-local-variable 'make-backup-files)
  1370.       (setq make-backup-files nil))
  1371.  
  1372.     ;; Don't get confirmation to delete dumped files when loading
  1373.     (if (eq S-keep-dump-files 'check)
  1374.         (setq S-keep-dump-files nil))
  1375.  
  1376.     ;; Delete the file if necessary
  1377.     (if S-delete-dump-files
  1378.         (delete-file (buffer-file-name)))))
  1379.  
  1380. (defun S-find-dump-file-other-window (filename)
  1381.   "Find S source file FILENAME in another window."
  1382.   (if (file-exists-p filename) nil
  1383.     (error "%s does not exist." filename))
  1384.  
  1385.   ;; Generate a buffer with the dumped data
  1386.   (find-file-other-window filename)
  1387.   (S-mode)
  1388.  
  1389.   (auto-save-mode 1)            ; Auto save in this buffer
  1390.   (setq S-local-process-name S-current-process-name)
  1391.  
  1392.   (if S-function-template
  1393.       (progn
  1394.         (goto-char (point-max))
  1395.         (if (re-search-backward S-dumped-missing-re nil t)
  1396.             (progn
  1397.               (replace-match S-function-template t t)
  1398.               (set-buffer-modified-p nil) ; Don't offer to save if killed now
  1399.               (goto-char (point-min))
  1400.               (condition-case nil
  1401.                   ;; This may fail if there are no opens
  1402.                   (down-list 1)
  1403.                 (error nil)))))))
  1404.  
  1405.  
  1406. ;; AJR: XEmacs, makes sense to dump into "other frame".
  1407.  
  1408. (defun S-dump-object-into-edit-buffer-other-frame (object)
  1409.   "Edit an S object in its own frame."
  1410.   (switch-to-buffer-other-frame (S-dump-object-into-edit-buffer object)))
  1411.  
  1412.  
  1413.  
  1414. (provide 'S-mode)
  1415.  
  1416. ;;; Local variables section
  1417.  
  1418. ;;; This file is automatically placed in Outline minor mode.
  1419. ;;; The file is structured as follows:
  1420. ;;; Chapters:     ^L ;
  1421. ;;; Sections:    ;;*;;
  1422. ;;; Subsections: ;;;*;;;
  1423. ;;; Components:  defuns, defvars, defconsts
  1424. ;;;              Random code beginning with a ;;;;* comment
  1425.  
  1426. ;;; Local variables:
  1427. ;;; mode: emacs-lisp
  1428. ;;; mode: outline-minor
  1429. ;;; outline-regexp: "\^L\\|\\`;\\|;;\\*\\|;;;\\*\\|(def[cvu]\\|(setq\\|;;;;\\*"
  1430. ;;; End:
  1431.  
  1432. ;;; S-mode.el ends here
  1433.  
  1434.